(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

(*-----------------------------------------------------------------------*)

open Location
open Pycaml
open Python_tools
open UniTools
open UTypes
  
(*-----------------------------------------------------------------------*)

type internal_location = {
  filename       : UniText.t;        (* the filename *)
  mutable line   : int;              (* the current line and column *)
  mutable column : int;
  fixed          : bool
}

(* Should <line> and <column> be increased when reading from the file? *)
let create_location filename fixed =
  { filename = filename;
    line = 0;
    column = 0;
    fixed = fixed }
  
let make_internal_location (name, line, col) fixed =
  { filename = name;
    line = line;
    column = col;
    fixed = fixed }
  
let duplicate_location loc =
  { filename = loc.filename;
    line = loc.line;
    column = loc.column;
    fixed = loc.fixed }
  
let fix_location loc =
  if loc.fixed then
    loc
  else
    { loc with fixed = true }
  
let inc_line loc =
  if not loc.fixed then
    (loc.line <- loc.line + 1;
     loc.column <- 0)
  
let inc_column loc =
  if not loc.fixed then
    loc.column <- loc.column + 1
  
let update_location loc char =
  if char = 10 then
    inc_line loc
  else
    inc_column loc
  
(* streams *)
type simple_stream = {
  mutable chars : uc_list;
  loc : internal_location
}

let duplicate_simple_stream str =
  { str with loc = duplicate_location str.loc }
  
type istream = {
  mutable current : simple_stream;
  mutable stack   : simple_stream list
}

let create () =
  { stack = [];
    current = { chars = [];
                loc = create_location UniText.empty true } }
  
let of_list s =
  { stack = [];
    current = { chars = s;
                loc = create_location UniText.empty true } }
  
let to_list is =
  List.concat (is.current.chars :: (List.map (fun s -> s.chars) is.stack))
  
let of_string s = of_list (Array.to_list s)
  
let to_string is = Array.of_list (to_list is)
  
let assign is1 is2 =
  is1.current <- duplicate_simple_stream is2.current;
  is1.stack <- List.map duplicate_simple_stream is2.stack
  
let exchange is1 is2 =
  let temp = { current = is1.current; stack = is1.stack } in
    assign is1 is2;
    assign is2 temp
  
let duplicate is =
  { current = duplicate_simple_stream is.current;
    stack = List.map duplicate_simple_stream is.stack }
  
let location is =
  (is.current.loc.filename, is.current.loc.line, is.current.loc.column)
  
let set_location is loc fixed =
  is.current <- { is.current with loc = make_internal_location loc fixed }
  
let get_char is pos =
  let rec iter pos chars stack =
    match chars with
      | c :: cs -> if pos = 0 then c else iter (pos - 1) cs stack
      | [] ->
          begin
            match stack with
              | [] -> (-1)
              | s :: ss -> iter pos s.chars ss
          end
  in
    iter pos is.current.chars is.stack
  
let eof is = (get_char is 0) < 0
  
let rec next_char is =
  match is.current.chars with
    | c :: _ -> c
    | [] ->
        begin
          match is.stack with
            | [] -> (-1)
            | s :: ss -> (is.current <- s; is.stack <- ss; next_char is)
        end
  
let take is num =
  let rec iter n chars stack =
    if n <= 0 then
      []
    else
      match chars with
        | c :: cs -> c :: (iter (n - 1) cs stack)
        | [] ->
            begin
              match stack with
                | s :: ss -> iter n s.chars ss
                | [] -> []
            end
  in
    iter num is.current.chars is.stack
  
let rec pop is =
  match is.current.chars with
    | c :: cs -> (is.current.chars <- cs; update_location is.current.loc c; c)
    | [] ->
        begin
          match is.stack with
            | [] -> (-1)
            | s :: ss ->
                is.current <- s;
                is.stack <- ss;
                pop is
        end
  
let remove is num =
  let rec iter n =
    if n <= 0 || pop is < 0 then
      ()
    else
      iter (n - 1)
  in
    iter num
  
let clear is =
  let rec iter last stack =
    match stack with
      | s :: ss -> iter s ss
      | [] ->
          is.current <- last;
          is.stack <- [];
          while next_char is >= 0 do
            ()
          done
  in
    iter is.current is.stack
  
let match_prefix is str =
  let rec iter str chars stack =
    match str with
      | [] -> true
      | c :: cs ->
          match chars with
            | x :: xs -> if c = x then iter cs xs stack else false
            | [] ->
                begin
                  match stack with
                    | [] -> false
                    | s :: ss -> iter str s.chars ss
                end
  in
    iter str is.current.chars is.stack
  
(* creating streams *)
let insert_list is str =
  is.stack <- is.current :: is.stack;
  is.current <- { chars = str; loc = fix_location is.current.loc }
  
let insert_string is str = insert_list is (Array.to_list str)
  
let insert_stream is stream =
  if stream.current.loc.filename = UniText.empty then
    let loc = fix_location is.current.loc in
      is.stack <- (List.map (fun s -> { s with loc = loc }) stream.stack) @ (is.current :: is.stack);
      is.current <- { (stream.current) with loc = loc }
  else
    begin
      is.stack <- stream.stack @ (is.current :: is.stack);
      is.current <- stream.current
    end
  
let include_file is name =
  let buf = ListBuilder.make () in
  let rec iter s =
    if IO.eof s then
      ListBuilder.get buf
    else
      let c = UString.read_uc_char s in
        if c >= 0 then
          ListBuilder.add buf c;
        iter s
  in
    try
      let s = IO.make_in_stream name in
        is.stack <- is.current :: is.stack;
        is.current <- { chars = iter s; loc = create_location name false };
        IO.free s
    with
      | _ -> ()
  
let of_file name =
  let stream = create () in
    include_file stream name;
    stream

(*-----------------------------------------------------------------------*)

let _ =
  register_ocamlpill_types
    [|
      "istream";
    |]

let (pythonize_istream, unpythonize_istream) = make_pill_wrapping "istream" (create ())

let py_istream_exchange =
  python_interfaced_function
    [| CamlpillSubtype "istream"; CamlpillSubtype "istream" |]
    begin
      fun py_args ->
        let is1 = unpythonize_istream py_args.(0) in
        let is2 = unpythonize_istream py_args.(1) in
          exchange is1 is2;
          pynone ();
    end

let py_istream_include_file =
  python_interfaced_function
    [| CamlpillSubtype "istream"; EitherStringType |]
    begin
      fun py_args ->
        let is = unpythonize_istream py_args.(0) in
        let name = UniText.unpythonize py_args.(1) in
          include_file is name;
          pynone ();
    end

let py_istream_insert_string =
  python_interfaced_function
    [| CamlpillSubtype "istream"; EitherStringType |]
    begin
      fun py_args ->
        let is = unpythonize_istream py_args.(0) in
        let s = UString.utf8_to_uc_string (unpythonize_string py_args.(1)) in
          insert_string is s;
          pynone ();
    end

let py_istream_of_file =
  python_interfaced_function
    [| EitherStringType |]
    (fun py_args -> pythonize_istream (of_file (UniText.unpythonize py_args.(0))))

let py_istream_of_string =
  python_interfaced_function
    [| EitherStringType |]
    begin
      fun py_args ->
        let s = UString.utf8_to_uc_string (unpythonize_string py_args.(0)) in
          pythonize_istream (of_string s)
    end

let _ =
  register_for_python
    [|
      ("istream_exchange", py_istream_exchange);
      ("istream_include_file", py_istream_include_file);
      ("istream_insert_string", py_istream_insert_string);
      ("istream_of_file", py_istream_of_file);
      ("istream_of_string", py_istream_of_string);
    |]

(*-----------------------------------------------------------------------*)
